home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
CALENDAR
/
MWCAL10
/
MWCAL10.ZIP
/
MWCalendar.pas
< prev
Wrap
Pascal/Delphi Source File
|
1996-11-08
|
14KB
|
468 lines
unit MWCalendar;
interface
uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics,
ExtCtrls;
type
DayStr = String[2];
TMWCalendarBevel = (bvLowered, bvRaised);
TMWCalendarBorderStyle = (bsNone, bsSingle);
TMWCalendar = class(TGraphicControl)
FDaysThisMonth: Integer;
FDisplayBoxes: Boolean;
FActive: Boolean;
FOnChange: TNotifyEvent;
FCalendarDate: TDateTime;
FDay: Word;
FMonth: Word;
FYear: Word;
FDayOffset: Integer;
FMonthOffset: Integer;
FSaturdayFontColor: TColor;
FSundayFontColor: TColor;
FFontColor: TColor;
FBkColor: TColor;
FLightColor: TColor;
FDarkColor: TColor;
FBorderStyle: TMWCalendarBorderStyle;
FBevel: TMWCalendarBevel;
FCtl3D: Boolean;
FFocusControl: TWinControl;
private
procedure DoDrawText(var Rect: TRect; Flags: Word);
function GetTransparent: Boolean;
procedure SetCalendarDate(Value: TDateTime);
procedure SetFocusControl(Value: TWinControl);
procedure SetTransparent(Value: Boolean);
procedure SetCtl3D(Value: Boolean);
procedure SetBorderStyle(Value: TMWCalendarBorderStyle);
procedure SetBevel(Value: TMWCalendarBevel);
procedure SetBkColor(Value: TColor);
procedure SetLightColor(Value: TColor);
procedure SetDarkColor(Value: TColor);
procedure SetSaturdayColor(Value: TColor);
procedure SetSundayColor(Value: TColor);
procedure SetFontColor(Value: TColor);
procedure SetDayOffset(Value: Integer);
procedure ChangeMonth(Delta: Integer);
procedure SetActive(Value: Boolean);
procedure SetDisplayBoxes(Value: Boolean);
protected
function IsLeapYear(AYear: Integer): Boolean; virtual;
function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
function DaysThisMonth: Integer; virtual;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure Paint; override;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
property Width;
property Height;
property Font;
public
constructor Create(AOwner: TComponent); override;
property Canvas;
property CalendarDate: TDateTime read FCalendarDate write SetCalendarDate;
published
property DisplayBoxes: Boolean read FDisplayBoxes write SetDisplayBoxes default True;
property Active: Boolean read FActive write SetActive default True;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property DayOffset: Integer read FDayOffset write SetDayOffset default 1;
property Color;
property SaturdayColor: TColor read FSaturdayFontColor write SetSaturdayColor default clBlack;
property SundayColor: TColor read FSundayFontColor write SetSundayColor default clBlack;
property FontColor: TColor read FFontColor write SetFontColor default clBlack;
property Enabled;
property Transparent: Boolean read GetTransparent write SetTransparent default False;
property Visible;
property Ctl3D: Boolean read FCtl3D write SetCtl3D default False;
property BorderStyle: TMWCalendarBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
property BevelStyle: TMWCalendarBevel read FBevel write SetBevel default bvRaised;
property BkColor: TColor read FBkColor write SetBkColor default clBtnFace;
property LightColor: TColor read FLightColor write SetLightColor default clBtnHighlight;
property DarkColor: TColor read FDarkColor write SetDarkColor default clBtnShadow;
end;
procedure Register;
implementation
var
DayTable: array[0..6, 0..5] of Byte;
{ TMWCalendar }
constructor TMWCalendar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque, csReplicatable];
FDisplayBoxes := True;
FActive := True;
FSaturdayFontColor := clBlack;
FSundayFontColor := clBlack;
FFontColor := clBlack;
FBkColor := clBtnFace;
FLightColor := clBtnHighlight;
FDarkColor := clBtnShadow;
Width := 144;
Height := 148;
FDayOffset := 1;
FCtl3D := False;
FBorderStyle := bsNone;
FBevel := bvRaised;
CalendarDate := Now;
SetBounds(Left, Top, Width, Height);
end;
procedure TMWCalendar.DoDrawText(var Rect: TRect; Flags: Word);
var
Text: string;
begin
Text := LongMonthNames[FMonth]+' '+IntToStr(FYear);
if Text[1] in ['a'..'z'] then Text[1] := Char(Ord(Text[1])-32);
Flags := Flags or DT_NOPREFIX;
Canvas.Font := Font;
DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;
procedure TMWCalendar.Paint;
var
TheRect: TRect;
RectPlus: TRect;
TopColor: TColor;
BottomColor: TColor;
PenColor: TColor;
i, j: Integer;
DayText: DayStr;
begin
with Canvas do
begin
Font.Name := 'MS Sans Serif';
Font.Size := 8;
Font.Color := FFontColor;
if not Transparent then
begin
Brush.Color := Self.Color;
Brush.Style := bsSolid;
FillRect(ClientRect);
end;
Brush.Style := bsClear;
TheRect := ClientRect;
if FBorderStyle <> bsNone then
begin
if FCtl3D then
begin
TopColor := clBtnShadow;
BottomColor := clBtnHighlight;
Frame3D(Canvas, TheRect, TopColor, BottomColor, 1);
end
else
begin
PenColor := Pen.Color;
Pen.Color := clWindowFrame;
Rectangle(TheRect.Left, TheRect.Top, TheRect.Right, TheRect.Bottom);
Pen.Color := PenColor;
end;
InflateRect(TheRect, -1, -1);
end;
TopColor := FLightColor;
if FBevel = bvLowered then TopColor := FDarkColor;
BottomColor := FDarkColor;
if FBevel = bvLowered then BottomColor := FLightColor;
if FActive then
begin
RectPlus := Rect(TheRect.Left, TheRect.Top, TheRect.Left+17, TheRect.Top+17);
Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
RectPlus := Rect(18, TheRect.Top, TheRect.Right-17, TheRect.Top+17);
Pen.Color := FLightColor;
MoveTo(5, 8);
LineTo(11, 2);
Pen.Color := FDarkColor;
LineTo(11, 14);
LineTo(5, 8);
MoveTo(TheRect.Right-11, 2);
LineTo(TheRect.Right-5, 8);
LineTo(TheRect.Right-11, 14);
Pen.Color := FLightColor;
LineTo(TheRect.Right-11, 2);
end
else
RectPlus := Rect(TheRect.Left, TheRect.Top, TheRect.Right, TheRect.Top+17);
Frame3D(Canvas, RectPlus, FLightColor, FDarkColor, 1);
DoDrawText(RectPlus, (DT_EXPANDTABS or DT_WORDBREAK or DT_CENTER));
RectPlus := TheRect;
RectPlus.Top := TheRect.Top + 17;
Frame3D(Canvas, RectPlus, TopColor, BottomColor, 1);
SetTextAlign(Handle, TA_CENTER);
for i := 0 to 6 do
begin
case (i+FDayOffset) mod 7 of
0 : Font.Color := FSundayFontColor;
6 : Font.Color := FSaturdayFontColor;
else Font.Color := FFontColor;
end;
RectPlus := Rect(TheRect.Left + 2 + i*20, TheRect.Top + 20, TheRect.Left + 22 + i*20, TheRect.Top + 38);
DayText := ShortDayNames[(FDayOffset + i) mod 7 + 1];
if DayText = 'N.' then DayText := 'N';
TextOut(TheRect.Left + 11 + i*20, TheRect.Top + 22, DayText);
end;
for j := 1 to 6 do
for i := 0 to 6 do
if DayTable[i,j-1] <> 0 then
begin
case (i+FDayOffset) mod 7 of
0 : Font.Color := FSundayFontColor;
6 : Font.Color := FSaturdayFontColor;
else Font.Color := FFontColor;
end;
RectPlus := Rect(TheRect.Left + 2 + i*20, TheRect.Top + 20 + j*18, TheRect.Left + 22 + i*20, TheRect.Top + 38 + j*18);
if (DayTable[i,j-1] = FDay) and FActive then
begin
if FDisplayBoxes then
Frame3D(Canvas, RectPlus, TopColor, BottomColor, 1)
else
Frame3D(Canvas, RectPlus, BottomColor, TopColor, 1);
Brush.Color := FBkColor;
end
else
begin
if FDisplayBoxes then Frame3D(Canvas, RectPlus, BottomColor, TopColor, 1);
Brush.Style := bsClear;
end;
DayText := IntToStr(DayTable[i,j-1]);
TextRect(RectPlus, TheRect.Left + 12 + i*20, TheRect.Top + 22 + j*18, DayText);
end;
SetTextAlign(Handle, TA_LEFT);
end;
end;
function TMWCalendar.GetTransparent: Boolean;
begin
Result := not (csOpaque in ControlStyle);
end;
procedure TMWCalendar.SetCalendarDate(Value: TDateTime);
var
i,j,k: Integer;
TmpDate: TDateTime;
begin
FCalendarDate := Value;
DecodeDate(CalendarDate, FYear, FMonth, FDay);
TmpDate := EncodeDate(FYear, FMonth, 1);
FMonthOffset := DayOfWeek(TmpDate)-1;
k := -((7-DayOffset+FMonthOffset) mod 7);
for j := 0 to 5 do
for i := 0 to 6 do
begin
Inc(k);
if (k < 0) or (k > DaysThisMonth) then
DayTable[i, j] := 0
else
DayTable[i, j] := k;
end;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TMWCalendar.SetFocusControl(Value: TWinControl);
begin
FFocusControl := Value;
if Value <> nil then Value.FreeNotification(Self);
end;
procedure TMWCalendar.SetTransparent(Value: Boolean);
begin
if Transparent <> Value then
begin
if Value then
ControlStyle := ControlStyle - [csOpaque] else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
procedure TMWCalendar.SetBkColor(Value: TColor);
begin
FBkColor := Value;
Invalidate;
end;
procedure TMWCalendar.SetLightColor(Value: TColor);
begin
FLightColor := Value;
Invalidate;
end;
procedure TMWCalendar.SetDarkColor(Value: TColor);
begin
FDarkColor := Value;
Invalidate;
end;
procedure TMWCalendar.SetDayOffset(Value: Integer);
begin
if (Value >=0) and (Value < 7) then
begin
FDayOffset := Value;
SetCalendarDate(CalendarDate);
end;
end;
procedure TMWCalendar.SetSaturdayColor(Value: TColor);
begin
FSaturdayFontColor := Value;
Invalidate;
end;
procedure TMWCalendar.SetSundayColor(Value: TColor);
begin
FSundayFontColor := Value;
Invalidate;
end;
procedure TMWCalendar.SetFontColor(Value: TColor);
begin
FFontColor := Value;
Invalidate;
end;
function TMWCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;
function TMWCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result := DaysInMonth[AMonth];
if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;
function TMWCalendar.DaysThisMonth: Integer;
begin
FDaysThisMonth := DaysPerMonth(FYear, FMonth);
Result := FDaysThisMonth;
end;
procedure TMWCalendar.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FFocusControl) then
FFocusControl := nil;
end;
procedure TMWCalendar.SetCtl3D(Value: Boolean);
begin
if FCtl3D <> Value then
begin
FCtl3D := Value;
Invalidate;
end;
end;
procedure TMWCalendar.SetBorderStyle(Value: TMWCalendarBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
if FBorderStyle = bsNone then
begin Width := 144; Height := 148; end
else
begin Width := 146; Height := 150; end;
SetBounds(Left, Top, Width, Height);
Invalidate;
end;
end;
procedure TMWCalendar.SetBevel(Value: TMWCalendarBevel);
begin
if FBevel <> Value then
begin
FBevel := Value;
SetBounds(Left, Top, Width, Height);
Invalidate;
end;
end;
procedure TMWCalendar.WMLButtonDown(var Message: TWMLButtonDown);
var
TheRect: TRect;
RectPlus: TRect;
i, j: Integer;
begin
SendCancelMode(Self);
inherited;
if FActive then
begin
TheRect := GetClientRect;
with Message do
begin
if (XPos>0) and (XPos<18) and (YPos>0) and (YPos<18) then
with Canvas do
begin
RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
Frame3D(Canvas, RectPlus, FDarkColor, FLightColor, 1);
ChangeMonth(-1);
end;
if (XPos>TheRect.Right-17) and (XPos<TheRect.Right) and (YPos>0) and (YPos<18) then
with Canvas do
begin
RectPlus := Rect(TheRect.Right-17, TheRect.Top, TheRect.Right, TheRect.Top+17);
Frame3D(Canvas, RectPlus, FDarkColor, FLightColor, 1);
ChangeMonth(1);
end;
if (XPos>2) and (XPos<TheRect.Right-2) and (YPos>37) then
begin
i := (XPos-2) div 20;
j := (YPos-38) div 18;
if DayTable[i,j] <> 0 then
CalendarDate := EncodeDate(FYear, FMonth, DayTable[i,j]);
end;
end;
end;
end;
procedure TMWCalendar.ChangeMonth(Delta: Integer);
var
AYear, AMonth, ADay: Word;
NewDate: TDateTime;
CurDay: Integer;
begin
DecodeDate(FCalendarDate, AYear, AMonth, ADay);
CurDay := ADay;
if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
else ADay := 1;
NewDate := EncodeDate(AYear, AMonth, ADay);
NewDate := NewDate + Delta;
DecodeDate(NewDate, AYear, AMonth, ADay);
if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
else ADay := DaysPerMonth(AYear, AMonth);
CalendarDate := EncodeDate(AYear, AMonth, ADay);
end;
procedure TMWCalendar.SetActive(Value: Boolean);
begin
FActive := Value;
Invalidate;
end;
procedure TMWCalendar.SetDisplayBoxes(Value: Boolean);
begin
FDisplayBoxes := Value;
Invalidate;
end;
procedure Register;
begin
RegisterComponents('MWCtrl', [TMWCalendar]);
end;
end.